home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / turbovis / ptg120co.zip / BBUTIL.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-06  |  14KB  |  118 lines
  1. (* This file was mangled by Mangler 1.13 (c) Copyright 1993 by Berend de Boer *)
  2.  {$IFDEF DPMI} {$F+,X+,R-,I-,S-,X+,D+} {$ELSE} {$F+,X+,O+,R-,I-,S-,D+} {$ENDIF} UNIT BBUTIL ;INTERFACE USES OBJECTS ;
  3. CONST PRNLINEFEED =#10;PRNFORMFEED =#12;PRNCR =#13;PRNNL =#13#10;PRNLARGEON =#27+ 'W'+ #1;PRNSMALLON =#15;
  4. PRNSMALLOFF =#18;PRNLARGEOFF =#27+ 'W'+ #0;PRNCAN =#24;PRNUNDON =#27+ '-1';PRNUNDOFF =#27+ '-0';PRNBOLDON =#27+ 'E';
  5. PRNBOLDOFF =#27+ 'F';PRNDOUBLEON =#27+ 'G';PRNDOUBLEOFF =#27+ 'H';CONST MAANDEN :ARRAY [ 1 .. 12 ]  OF STRING [ 9 ]
  6. =('januari', 'februari', 'maart', 'april', 'mei', 'juni', 'juli', 'augustus', 'september', 'oktober', 'november',
  7. 'december');CONST MAXWORD =$FFFF ;TYPE PSLINK =^TSLINK ;TSLINK =RECORD VALUE :PSTRING ;NEXT :PSLINK ;END ;
  8. VAR VALCODE :WORD ;FUNCTION STRB (N :BYTE ):STRING ;FUNCTION STRI (N :INTEGER ):STRING ;FUNCTION STRW (N :WORD ):STRING ;
  9. FUNCTION STRL (N :LONGINT ):STRING ;FUNCTION STRR (N :REAL ;WIDTH ,DECIMALS:WORD ):STRING ;FUNCTION LEADINGZERO
  10. (VALUE :WORD ):STRING ;FUNCTION HEXSTR (W :WORD ):STRING ;FUNCTION VALB (CONST S :STRING ):BYTE ;FUNCTION VALI
  11. (CONST S :STRING ):INTEGER ;FUNCTION VALW (CONST S :STRING ):WORD ;FUNCTION VALL (CONST S :STRING ):LONGINT ;
  12. FUNCTION VALR (CONST S :STRING ):REAL ;FUNCTION LOWCASE (C :CHAR ):CHAR ;FUNCTION LOWSTR (CONST S :STRING ):STRING ;
  13. FUNCTION UPSTR (CONST S :STRING ):STRING ;FUNCTION FANCYSTR (S :STRING ):STRING ;FUNCTION CPOS (C :CHAR ;CONST S :STRING
  14. ):BYTE ;FUNCTION EMPTY (CONST S :STRING ):BOOLEAN ;FUNCTION EXTRACTSTR (CONST FROM ,STARTSTR,ENDSTR:STRING ):STRING ;
  15. PROCEDURE FORMATSTR (VAR RESULT :STRING ;CONST FORMAT :STRING ;VAR PARAMS );FUNCTION FTCOPY (CONST S :STRING ;
  16. F ,T:WORD ):STRING ;FUNCTION GETDATESTR :STRING ;FUNCTION GETTIMESTR :STRING ;FUNCTION LEFTJUSTIFY (CONST S :STRING ;
  17. F_LEN :WORD ):STRING ;FUNCTION REPCHAR (C :CHAR ;COUNT :INTEGER ):STRING ;FUNCTION RIGHTJUSTIFY (CONST S :STRING ;
  18. F_LEN :WORD ):STRING ;FUNCTION SPC (COUNT :INTEGER ):STRING ;FUNCTION SPOILED (CONST S :STRING ):BOOLEAN ;
  19. FUNCTION STRIPSPC (CONST S :STRING ):STRING ;FUNCTION ZERORIGHTJUSTIFY (CONST S :STRING ;F_LEN :WORD ):STRING ;
  20. PROCEDURE FREESTR (P :PSTRING );FUNCTION GETSTR (P :PSTRING ):STRING ;PROCEDURE REPLACESTR (VAR P :PSTRING ;S :STRING );
  21. PROCEDURE BEEP ;FUNCTION CMPB (CONST PTR1 ,PTR2;SIZE :WORD ):INTEGER ;FUNCTION CMPW (CONST PTR1 ,PTR2;
  22. SIZE :WORD ):INTEGER ;PROCEDURE CALCCENTS (BEDRAG :LONGINT ;DIV1 ,DIV2:WORD ;VAR CENTS );PROCEDURE COMPARE
  23. (VAR PTR1 ,PTR2;RSIZE :WORD ;VAR FLAG :BYTE );FUNCTION DATEVALID (CONST S :STRING ):BOOLEAN ;PROCEDURE DISCARD (VAR P );
  24. PROCEDURE DISPOSESLINK (PS :PSLINK );PROCEDURE HORIZLINE ;PROCEDURE INCTOTAAL (VAR TOTAAL :LONGINT ;BEDRAG :LONGINT ;
  25. VAR CENTS );FUNCTION NEWSLINK (CONST STR :STRING ;ANEXT :PSLINK ):PSLINK ;PROCEDURE PRNWRITEDATE (YEAR ,MONTH,DAY:WORD );
  26. FUNCTION RND (R :REAL ):REAL ;FUNCTION SCANB (AREA :POINTER ;SIZE :WORD ;VALUE :BYTE ):WORD ;IMPLEMENTATION USES CRT ,
  27. PRINTER , DOS ;FUNCTION STRB (N:BYTE):STRING ;VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRB := OO1O ;END ;FUNCTION STRL
  28. (N:LONGINT):STRING ;VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRL := OO1O ;END ;FUNCTION STRW (N:WORD):STRING ;
  29. VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRW := OO1O ;END ;FUNCTION STRI (N:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN STR (N
  30. , OO1O );STRI := OO1O ;END ;FUNCTION STRR (N:REAL;WIDTH,DECIMALS:WORD):STRING ;VAR OO1O:STRING ;BEGIN STR (N :WIDTH
  31. :DECIMALS , OO1O );STRR := OO1O ;END ;FUNCTION LEADINGZERO (VALUE:WORD):STRING ;VAR OO1O:STRING ;BEGIN STR (VALUE , OO1O
  32. );IF LENGTH (OO1O )=1 THEN OO1O := '0'+ OO1O ;LEADINGZERO := OO1O ;END ;FUNCTION HEXSTR (W:WORD):STRING ;
  33. CONST OOIOOOI11OI1:ARRAY [ 0 .. 15 ]  OF CHAR='0123456789ABCDEF';BEGIN HEXSTR := OOIOOOI11OI1 [ (W SHR 12 )MOD 16 ] +
  34. OOIOOOI11OI1 [ (W SHR 8 )MOD 16 ] + OOIOOOI11OI1 [ (W SHR 4 )MOD 16 ] + OOIOOOI11OI1 [ W MOD 16 ] ;END ;FUNCTION VALB
  35. (CONST S:STRING ):BYTE ;VAR OIOO:WORD;BEGIN VAL (S , OIOO , VALCODE );VALB := LO (OIOO );END ;FUNCTION VALI
  36. (CONST S:STRING ):INTEGER ;VAR OIOO:INTEGER;BEGIN VAL (S , OIOO , VALCODE );VALI := OIOO ;END ;FUNCTION VALW
  37. (CONST S:STRING ):WORD ;VAR OIOO:WORD;BEGIN VAL (S , OIOO , VALCODE );VALW := OIOO ;END ;FUNCTION VALL (CONST S:STRING
  38. ):LONGINT ;VAR OIOO:LONGINT;BEGIN VAL (S , OIOO , VALCODE );VALL := OIOO ;END ;FUNCTION VALR (CONST S:STRING ):REAL ;
  39. VAR OO1I:REAL;BEGIN VAL (S , OO1I , VALCODE );VALR := OO1I ;END ;FUNCTION LOWCASE (C:CHAR):CHAR ;BEGIN IF C IN [ 'A'..
  40. 'Z'] THEN LOWCASE := CHR (ORD (C )+ (97 - 65 ))ELSE LOWCASE := C ;END ;FUNCTION LOWSTR (CONST S:STRING ):STRING ;
  41. ASSEMBLER;ASM {} PUSH DS {} CLD {} LDS SI , S{} LES DI , @Result {} LODSB {} STOSB {} XOR AH , AH {} XCHG AX , CX {}
  42. JCXZ @3 {} @1 : {} LODSB {} CMP AL , 'A' {} JB @2 {} CMP AL , 'Z' {} JA @2 {} ADD AL , 20H {} @2 : {} STOSB {} LOOP @1 {}
  43. @3 : {} POP DS {} END;FUNCTION UPSTR (CONST S:STRING ):STRING ;ASSEMBLER;ASM {} PUSH DS {} CLD {} LDS SI , S{}
  44. LES DI , @Result {} LODSB {} STOSB {} XOR AH , AH {} XCHG AX , CX {} JCXZ @3 {} @1 : {} LODSB {} CMP AL , 'a' {} JB @2 {}
  45. CMP AL , 'z' {} JA @2 {} SUB AL , 20H {} @2 : {} STOSB {} LOOP @1 {} @3 : {} POP DS {} END;FUNCTION FANCYSTR (S:STRING
  46. ):STRING ;VAR OIlO:WORD;BEGIN S [ 1 ] := UPCASE (S [ 1 ] );FOR OIlO := 2 TO LENGTH (S ) DO IF S [ OIlO - 1 ] <> ' 'THEN S
  47. [ OIlO ] := LOWCASE (S [ OIlO ] );FANCYSTR := S ;END ;FUNCTION CPOS (C:CHAR;CONST S:STRING ):BYTE ;ASSEMBLER;ASM {}
  48. MOV AL , C{} CLD {} LES DI , S{} MOV CL , ES : [ DI ] {} MOV AH , CL {} XOR CH , CH {} JCXZ @end {} INC DI {}
  49. REPNE SCASB {} JNZ @end {} NEG CL {} ADD CL , AH {} @end : {} MOV AL , CL {} END;FUNCTION EMPTY (CONST S:STRING ):BOOLEAN
  50. ;ASSEMBLER;ASM {} LES DI , S{} MOV CL , [ ES : DI ] {} XOR CH , CH {} JCXZ @Empty {} MOV AL , ' ' {} INC DI {} CLD {}
  51. REPE SCASB {} JZ @Empty {} MOV AX , 0 {} POP BP {} RET 4 {} @Empty : {} MOV AX , 1 {} END;FUNCTION EXTRACTSTR
  52. (CONST FROM,STARTSTR,ENDSTR:STRING ):STRING ;VAR OIlO,OIll:WORD;BEGIN IF STARTSTR =''THEN OIlO := 1 ELSE OIlO := POS
  53. (STARTSTR , FROM )+ LENGTH (STARTSTR );IF ENDSTR =''THEN OIll := LENGTH (FROM )ELSE OIll := POS (ENDSTR , FROM )- 1 ;IF
  54. (OIll < OIlO )AND (LENGTH (ENDSTR )=1 )THEN BEGIN OIll := OIlO ;WHILE FROM [ OIll ] <> ENDSTR [ 1 ]  DO INC (OIll );DEC
  55. (OIll );END ;EXTRACTSTR := FTCOPY (FROM , OIlO , OIll );END ;{$L FORMAT.OBJ} PROCEDURE FORMATSTR (VAR RESULT:STRING ;
  56. CONST FORMAT:STRING ;VAR PARAMS);EXTERNAL;FUNCTION FTCOPY (CONST S:STRING ;F,T:WORD):STRING ;BEGIN {$IFOPT Q+} {$Q-}
  57. FTCOPY := COPY (S , F , T - F + 1 );{$ELSE} FTCOPY := COPY (S , F , T - F + 1 );{$ENDIF} END ;FUNCTION GETDATESTR :STRING
  58. ;VAR OOIl,OO0I,OIOO,OIlO11001ll:WORD;BEGIN GETDATE (OOIl , OO0I , OIOO , OIlO11001ll );GETDATESTR := STRW (OOIl )+ '-'+
  59. LEADINGZERO (OO0I )+ '-'+ LEADINGZERO (OIOO );END ;FUNCTION GETTIMESTR :STRING ;VAR OIlI,OO0I,OO1O,O11l0Il0:WORD;
  60. BEGIN GETTIME (OIlI , OO0I , OO1O , O11l0Il0 );GETTIMESTR := LEADINGZERO (OIlI )+ ':'+ LEADINGZERO (OO0I )+ ':'+
  61. LEADINGZERO (OO1O );END ;FUNCTION LEFTJUSTIFY (CONST S:STRING ;F_LEN:WORD):STRING ;BEGIN LEFTJUSTIFY := COPY (S + SPC
  62. (ABS (F_LEN - LENGTH (S ))), 1 , F_LEN );END ;FUNCTION REPCHAR (C:CHAR;COUNT:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN IF
  63. COUNT <= 0 THEN REPCHAR := ''ELSE BEGIN FILLCHAR (OO1O [ 1 ] , COUNT , C );OO1O [ 0 ] := CHR (COUNT );REPCHAR := OO1O ;
  64. END ;END ;FUNCTION RIGHTJUSTIFY (CONST S:STRING ;F_LEN:WORD):STRING ;VAR OIOO:STRING ;BEGIN OIOO := SPC (ABS (F_LEN -
  65. LENGTH (S )))+ S ;RIGHTJUSTIFY := COPY (OIOO , LENGTH (OIOO )- F_LEN + 1 , F_LEN );END ;FUNCTION SPC
  66. (COUNT:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN IF COUNT <= 0 THEN SPC := ''ELSE BEGIN FILLCHAR (OO1O [ 1 ] , ABS (COUNT
  67. ), ' ');OO1O [ 0 ] := CHR (ABS (COUNT ));SPC := OO1O ;END ;END ;FUNCTION SPOILED (CONST S:STRING ):BOOLEAN ;ASSEMBLER;
  68. ASM {} CLD {} LES SI , S{} MOV CL , [ ES : SI ] {} XOR CH , CH {} JCXZ @end {} INC SI {} @next : SEGES LODSB {}
  69. CMP AL , 32 {} JB @stop {} CMP AL , 163 {} JA @stop {} LOOP @next {} @end : MOV AL , 0 {} POP BP {} RET 4 {}
  70. @stop : MOV AL , 1 {} END;FUNCTION STRIPSPC (CONST S:STRING ):STRING ;ASSEMBLER;ASM {} LES DI , S{}
  71. MOV CL , [ ES : DI ] {} MOV CH , 0 {} JCXZ @end {} MOV AL , ' ' {} ADD DI